-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Wire.UserStore.Cassandra (interpretUserStoreCassandra) where

import Cassandra
import Cassandra.Exec (prepared)
import Control.Lens ((^.))
import Data.Handle
import Data.Id
import Data.Time.Clock
import Database.CQL.Protocol
import Imports
import Polysemy
import Polysemy.Embed
import Polysemy.Error
import Wire.API.Password (Password)
import Wire.API.Provider.Service
import Wire.API.User hiding (DeleteUser)
import Wire.API.User.RichInfo
import Wire.API.User.Search (SetSearchable (SetSearchable))
import Wire.StoredUser
import Wire.UserStore
import Wire.UserStore.IndexUser hiding (userId)
import Wire.UserStore.Unique

interpretUserStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor UserStore r
interpretUserStoreCassandra casClient =
  interpret $
    runEmbedded (runClient casClient) . embed . \case
      CreateUser new mbConv -> createUserImpl new mbConv
      GetUsers uids -> getUsersImpl uids
      GetIndexUser uid -> getIndexUserImpl uid
      GetIndexUsersPaginated pageSize mPagingState -> getIndexUserPaginatedImpl pageSize mPagingState
      UpdateUser uid update -> updateUserImpl uid update
      UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid email
      UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update
      DeleteUser user -> deleteUserImpl user
      LookupHandle hdl -> lookupHandleImpl LocalQuorum hdl
      GlimpseHandle hdl -> lookupHandleImpl One hdl
      LookupStatus uid -> lookupStatusImpl uid
      IsActivated uid -> isActivatedImpl uid
      LookupLocale uid -> lookupLocaleImpl uid
      GetUserTeam uid -> getUserTeamImpl uid
      UpdateUserTeam uid tid -> updateUserTeamImpl uid tid
      GetActivityTimestamps uid -> getActivityTimestampsImpl uid
      GetRichInfo uid -> getRichInfoImpl uid
      GetUserAuthenticationInfo uid -> getUserAuthenticationInfoImpl uid
      DeleteEmail uid -> deleteEmailImpl uid
      SetUserSearchable uid searchable -> setUserSearchableImpl uid searchable

createUserImpl :: NewStoredUser -> Maybe (ConvId, Maybe TeamId) -> Client ()
createUserImpl new mbConv = retry x5 . batch $ do
  setType BatchLogged
  setConsistency LocalQuorum
  addPrepQuery insertUser (asTuple new)
  for_ ((,) <$> new.service <*> mbConv) $ \(sref, (cid, mbTid)) -> do
    let pid = sref ^. serviceRefProvider
        sid = sref ^. serviceRefId
    addPrepQuery insertServiceUser (pid, sid, BotId new.id, cid, mbTid)
    for_ mbTid $ \tid ->
      addPrepQuery insertServiceTeam (pid, sid, BotId new.id, cid, tid)

getUserAuthenticationInfoImpl :: UserId -> Client (Maybe (Maybe Password, AccountStatus))
getUserAuthenticationInfoImpl uid = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity uid)))
  where
    f (pw, st) = (pw, fromMaybe Active st)
    authSelect :: PrepQuery R (Identity UserId) (Maybe Password, Maybe AccountStatus)
    authSelect =
      [sql|
        SELECT password, status FROM user WHERE id = ?
      |]

getUsersImpl :: [UserId] -> Client [StoredUser]
getUsersImpl usrs =
  map asRecord
    <$> retry x1 (query selectUsers (params LocalQuorum (Identity usrs)))

getIndexUserImpl :: UserId -> Client (Maybe IndexUser)
getIndexUserImpl u = do
  mIndexUserTuple <- retry x1 $ query1 cql (params LocalQuorum (Identity u))
  pure $ asRecord <$> mIndexUserTuple
  where
    cql :: PrepQuery R (Identity UserId) (TupleType IndexUser)
    cql = prepared . QueryString $ getIndexUserBaseQuery <> " WHERE id = ?"

getIndexUserPaginatedImpl :: Int32 -> Maybe PagingState -> Client (PageWithState IndexUser)
getIndexUserPaginatedImpl pageSize mPagingState =
  asRecord <$$> paginateWithState cql (paramsPagingState LocalQuorum () pageSize mPagingState)
  where
    cql :: PrepQuery R () (TupleType IndexUser)
    cql = prepared $ QueryString getIndexUserBaseQuery

getIndexUserBaseQuery :: LText
getIndexUserBaseQuery =
  [sql|
    SELECT
    id,
    team, writetime(team),
    name, writetime(name),
    status, writetime(status),
    handle, writetime(handle),
    email, writetime(email),
    accent_id, writetime(accent_id),
    activated, writetime(activated),
    service, writetime(service),
    managed_by, writetime(managed_by),
    sso_id, writetime(sso_id),
    email_unvalidated, writetime(email_unvalidated),
    searchable, writetime(searchable),
    writetime(write_time_bumper)
    FROM user
  |]

updateUserImpl :: UserId -> StoredUserUpdate -> Client ()
updateUserImpl uid update =
  retry x5 $ batch do
    -- PERFORMANCE(fisx): if a user changes 4 attributes with one request, the database will
    -- be hit with one request for each attribute.  this is probably fine, since this
    -- operation is not heavily used.  (also, the four operations are batched, which may or
    -- may not help.)
    setType BatchLogged
    setConsistency LocalQuorum
    for_ update.name \n -> addPrepQuery userDisplayNameUpdate (n, uid)
    for_ update.textStatus \s -> addPrepQuery userTextStatusUpdate (s, uid)
    for_ update.pict \p -> addPrepQuery userPictUpdate (p, uid)
    for_ update.assets \a -> addPrepQuery userAssetsUpdate (a, uid)
    for_ update.locale \a -> addPrepQuery userLocaleUpdate (a.lLanguage, a.lCountry, uid)
    for_ update.accentId \c -> addPrepQuery userAccentIdUpdate (c, uid)
    for_ update.supportedProtocols \a -> addPrepQuery userSupportedProtocolsUpdate (a, uid)

updateEmailUnvalidatedImpl :: UserId -> EmailAddress -> Client ()
updateEmailUnvalidatedImpl u e =
  retry x5 $ write userEmailUnvalidatedUpdate (params LocalQuorum (e, u))
  where
    userEmailUnvalidatedUpdate :: PrepQuery W (EmailAddress, UserId) ()
    userEmailUnvalidatedUpdate = "UPDATE user SET email_unvalidated = ? WHERE id = ?"

updateUserHandleEitherImpl :: UserId -> StoredUserHandleUpdate -> Client (Either StoredUserUpdateError ())
updateUserHandleEitherImpl uid update =
  runM $ runError do
    claimed <- embed $ claimHandleImpl uid update.old update.new
    unless claimed $ throw StoredUserUpdateHandleExists

-- | Claim a new handle for an existing 'User': validate it, and in case of success, assign it
-- to user and mark it as taken.
claimHandleImpl :: UserId -> Maybe Handle -> Handle -> Client Bool
claimHandleImpl uid oldHandle newHandle =
  isJust <$> do
    owner <- lookupHandleImpl LocalQuorum newHandle
    case owner of
      Just uid' | uid /= uid' -> pure Nothing
      _ -> do
        let key = "@" <> fromHandle newHandle
        withClaim uid key (30 # Minute) $
          do
            -- Record ownership
            retry x5 $ write handleInsert (params LocalQuorum (newHandle, uid))
            -- Update profile
            result <- updateHandle uid newHandle
            -- Free old handle (if it changed)
            for_ (mfilter (/= newHandle) oldHandle) $
              freeHandleImpl uid
            pure result
  where
    updateHandle :: UserId -> Handle -> Client ()
    updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u))

-- | Free a 'Handle', making it available to be claimed again.
freeHandleImpl :: UserId -> Handle -> Client ()
freeHandleImpl uid h = do
  mbHandleUid <- lookupHandleImpl LocalQuorum h
  case mbHandleUid of
    Just handleUid | handleUid == uid -> do
      retry x5 $ write handleDelete (params LocalQuorum (Identity h))
      let key = "@" <> fromHandle h
      deleteClaim uid key (30 # Minute)
    _ -> pure () -- this shouldn't happen, the call side should always check that `h` and `uid` belong to the same account.

-- | Sending an empty 'Handle' here causes C* to throw "Key may not be empty"
-- error.
lookupHandleImpl :: Consistency -> Handle -> Client (Maybe UserId)
lookupHandleImpl consistencyLevel h = do
  (runIdentity =<<)
    <$> retry x1 (query1 handleSelect (params consistencyLevel (Identity h)))

deleteUserImpl :: User -> Client ()
deleteUserImpl user = do
  for_ (userHandle user) \h ->
    freeHandleImpl (userId user) h
  retry x5 $
    write
      updateUserToTombstone
      ( params
          LocalQuorum
          (Deleted, Name "default", defaultAccentId, noPict, [], userId user)
      )

lookupStatusImpl :: UserId -> Client (Maybe AccountStatus)
lookupStatusImpl u =
  (runIdentity =<<)
    <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u)))

isActivatedImpl :: UserId -> Client Bool
isActivatedImpl uid =
  (== Just (Identity True))
    <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity uid)))

lookupLocaleImpl :: UserId -> Client (Maybe (Maybe Language, Maybe Country))
lookupLocaleImpl u = do
  retry x1 (query1 localeSelect (params LocalQuorum (Identity u)))

getUserTeamImpl :: UserId -> Client (Maybe TeamId)
getUserTeamImpl u = (runIdentity =<<) <$> retry x1 (query1 q (params LocalQuorum (Identity u)))
  where
    q :: PrepQuery R (Identity UserId) (Identity (Maybe TeamId))
    q = "SELECT team FROM user WHERE id = ?"

updateUserTeamImpl :: UserId -> TeamId -> Client ()
updateUserTeamImpl u t = retry x5 $ write userTeamUpdate (params LocalQuorum (t, u))
  where
    userTeamUpdate :: PrepQuery W (TeamId, UserId) ()
    userTeamUpdate = "UPDATE user SET team = ? WHERE id = ?"

getActivityTimestampsImpl :: UserId -> Client [Maybe UTCTime]
getActivityTimestampsImpl uid = do
  runIdentity <$$> retry x1 (query q (params LocalQuorum (Identity uid)))
  where
    q :: PrepQuery R (Identity UserId) (Identity (Maybe UTCTime))
    q = "SELECT last_active from clients where user = ?"

getRichInfoImpl :: UserId -> Client (Maybe RichInfoAssocList)
getRichInfoImpl uid =
  fmap runIdentity
    <$> retry x1 (query1 q (params LocalQuorum (Identity uid)))
  where
    q :: PrepQuery R (Identity UserId) (Identity RichInfoAssocList)
    q = "SELECT json FROM rich_info WHERE user = ?"

deleteEmailImpl :: UserId -> Client ()
deleteEmailImpl u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u))

setUserSearchableImpl :: UserId -> SetSearchable -> Client ()
setUserSearchableImpl uid (SetSearchable searchable) = retry x5 $ write q (params LocalQuorum (searchable, uid))
  where
    q :: PrepQuery W (Bool, UserId) ()
    q = "UPDATE user SET searchable = ? WHERE id = ?"

--------------------------------------------------------------------------------
-- Queries

insertUser :: PrepQuery W (TupleType NewStoredUser) ()
insertUser =
  "INSERT INTO user (id, name, text_status, picture, assets, email, sso_id, \
  \accent_id, password, activated, status, expires, language, \
  \country, provider, service, handle, team, managed_by, supported_protocols, searchable) \
  \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"

insertServiceUser :: PrepQuery W (ProviderId, ServiceId, BotId, ConvId, Maybe TeamId) ()
insertServiceUser =
  "INSERT INTO service_user (provider, service, user, conv, team) \
  \VALUES (?, ?, ?, ?, ?)"

insertServiceTeam :: PrepQuery W (ProviderId, ServiceId, BotId, ConvId, TeamId) ()
insertServiceTeam =
  "INSERT INTO service_team (provider, service, user, conv, team) \
  \VALUES (?, ?, ?, ?, ?)"

selectUsers :: PrepQuery R (Identity [UserId]) (TupleType StoredUser)
selectUsers =
  [sql|
  SELECT id, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets,
  activated, status, expires, language, country, provider,
  service, handle, team, managed_by, supported_protocols, searchable
  FROM user WHERE id IN ?
  |]

userDisplayNameUpdate :: PrepQuery W (Name, UserId) ()
userDisplayNameUpdate = "UPDATE user SET name = ? WHERE id = ?"

userTextStatusUpdate :: PrepQuery W (TextStatus, UserId) ()
userTextStatusUpdate = "UPDATE user SET text_status = ? WHERE id = ?"

userPictUpdate :: PrepQuery W (Pict, UserId) ()
userPictUpdate = "UPDATE user SET picture = ? WHERE id = ?"

userAssetsUpdate :: PrepQuery W ([Asset], UserId) ()
userAssetsUpdate = "UPDATE user SET assets = ? WHERE id = ?"

userAccentIdUpdate :: PrepQuery W (ColourId, UserId) ()
userAccentIdUpdate = "UPDATE user SET accent_id = ? WHERE id = ?"

userLocaleUpdate :: PrepQuery W (Language, Maybe Country, UserId) ()
userLocaleUpdate = "UPDATE user SET language = ?, country = ? WHERE id = ?"

userSupportedProtocolsUpdate :: PrepQuery W (Imports.Set BaseProtocolTag, UserId) ()
userSupportedProtocolsUpdate = "UPDATE user SET supported_protocols = ? WHERE id = ?"

handleInsert :: PrepQuery W (Handle, UserId) ()
handleInsert = "INSERT INTO user_handle (handle, user) VALUES (?, ?)"

handleSelect :: PrepQuery R (Identity Handle) (Identity (Maybe UserId))
handleSelect = "SELECT user FROM user_handle WHERE handle = ?"

handleDelete :: PrepQuery W (Identity Handle) ()
handleDelete = "DELETE FROM user_handle WHERE handle = ?"

userHandleUpdate :: PrepQuery W (Handle, UserId) ()
userHandleUpdate = "UPDATE user SET handle = ? WHERE id = ?"

updateUserToTombstone :: PrepQuery W (AccountStatus, Name, ColourId, Pict, [Asset], UserId) ()
updateUserToTombstone =
  "UPDATE user SET status = ?, name = ?,\
  \ accent_id = ?, picture = ?, assets = ?, handle = null, country = null,\
  \ language = null, email = null, sso_id = null WHERE id = ?"

statusSelect :: PrepQuery R (Identity UserId) (Identity (Maybe AccountStatus))
statusSelect = "SELECT status FROM user WHERE id = ?"

activatedSelect :: PrepQuery R (Identity UserId) (Identity Bool)
activatedSelect = "SELECT activated FROM user WHERE id = ?"

localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country)
localeSelect = "SELECT language, country FROM user WHERE id = ?"

userEmailDelete :: PrepQuery W (Identity UserId) ()
userEmailDelete = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email = null, write_time_bumper = 0 WHERE id = ?"
